home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1999 April / macformat-075.iso / Shareware Plus / Applications / Alpha / Tcl / SystemCode / CorePackages / aecoerce.tcl < prev    next >
Encoding:
Text File  |  1998-12-16  |  6.0 KB  |  222 lines  |  [TEXT/ALFA]
  1. ## -*-Tcl-*-
  2.  # ###################################################################
  3.  #  AECoerce - Coersion functions for AEGizmo values
  4.  # 
  5.  #  FILE: "aecoerce.tcl"
  6.  #                                    created: 3/3/98 {11:53:59 PM} 
  7.  #                                last update: 16/12/1998 {2:07:58 pm} 
  8.  #                                    version: 1.1
  9.  #  Author: Jonathan Guyer
  10.  #  E-mail: <jguyer@his.com>
  11.  #     www: <http://www.his.com/~jguyer/>
  12.  #  
  13.  # Copyright (c) 1998  Jonathan Guyer
  14.  # 
  15.  # This program is free software; you can redistribute it and/or modify
  16.  # it under the terms of the GNU General Public License as published by
  17.  # the Free Software Foundation; either version 2 of the License, or
  18.  # (at your option) any later version.
  19.  # 
  20.  # This program is distributed in the hope that it will be useful,
  21.  # but WITHOUT ANY WARRANTY; without even the implied warranty of
  22.  # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  23.  # GNU General Public License for more details.
  24.  # 
  25.  # You should have received a copy of the GNU General Public License
  26.  # along with this program; if not, write to the Free Software
  27.  # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  28.  # See the file "license.terms" for information on usage and 
  29.  # redistribution of this file, and for a DISCLAIMER OF ALL 
  30.  # WARRANTIES.
  31.  #  
  32.  # ###################################################################
  33.  ##
  34.  
  35. namespace eval aecoerce {}
  36.  
  37. ensureset aecoerce::overrides {}
  38. ensureset aecoerce::noCoerce {}
  39.     
  40. proc aecoerce::identity {value} {
  41.     return $value
  42. }
  43.  
  44. ## 
  45.  # bool ::= bool(«00|01»)
  46.  ##
  47. proc aecoerce::hexd:bool {value} {
  48.     set value [aecoerce::hexd $value]
  49.     set bool [expr {"0x$value"}]
  50.     if {($bool != 0) && ($bool != 1)} {
  51.         set msg "Can't coerce «$value» from 'hexd' to 'bool'"
  52.         error $msg "" [list AECoerce -1700 $msg]
  53.     } 
  54.     return $bool
  55. }
  56.  
  57. proc aecoerce::hexd:TEXT {value} {
  58.     # make sure input is really hexd
  59.     set value [aecoerce::hexd $value]
  60.     
  61.     set TEXT ""
  62.     while {[string length $value]} {
  63.         append TEXT [uplevel 0 "set temp \\x[string range $value 0 1]"]
  64.         set value [string range $value 2 end]
  65.     }
  66.     return $TEXT
  67. }
  68.  
  69. proc aecoerce::hexd {value} {
  70.     regsub -all -nocase "\[ \t\r\n\]" $value "" newval
  71.     if {[expr {[string length $newval] % 2}]} {
  72.         # left pad with zero to make even number of digits
  73.         set newval "0${newval}"
  74.     } 
  75.     if {![is::Hexadecimal $newval]} {
  76.         set msg "Non-hex-digit in «${value}»" 
  77.         error $msg "" [list AECoerce 6 $msg]
  78.     } else {
  79.         return ${newval}
  80.     }
  81. }
  82.  
  83. proc aecoerce::null:TEXT {value} {
  84.     return ""
  85. }
  86.  
  87. proc aecoerce::hexd:alis {value} {
  88.     return [aeparse::keywordValue ---- \
  89.         [aeparse::event \
  90.             [AEBuild -r 'MACS' core getd ---- \
  91.                 "obj {form:alis, want:file, from:'null'(), \
  92.                         seld:[aebuild::coercion "alis" [aebuild::hexd $value]] \
  93.                 }" \
  94.                 rtyp TEXT
  95.             ] \
  96.         ] \
  97.     ]
  98. }
  99.  
  100. proc aecoerce::TEXT:alis {value} {
  101.     return [coerce TEXT $value -x alis]
  102. }
  103.  
  104. proc aecoerce::register {from to proc} {
  105.     global aecoerce::coercions
  106.     
  107.     if {$from == $to} {
  108.         error "Coercing '$from' to '$to' is just stupid!"
  109.     } 
  110.     
  111.     set procs ""
  112.     if {![info exists aecoerce::coercions]} {
  113.         set aecoerce::coercions ""
  114.     }
  115.     set coercions ${aecoerce::coercions}
  116.     
  117.     set new [list $from $to *]
  118.     while {[set i [lsearch -glob $coercions $new]] != -1} {
  119.         lappend procs [lindex [lindex $coercions $i] 2]
  120.         set coercions [lrange $coercions [incr i] end]
  121.     }
  122.     
  123.     if {[llength $procs]} {
  124.         
  125.         set procs [lsort [lunique [lappend procs $proc]]]
  126.         if {[llength $procs] > 1} {
  127.             set proc \
  128.               [listpick -p \
  129.                   "Only one coersion from '$from' to '$to' is allowed:" \
  130.                 $procs \
  131.               ]
  132.             set procs [lremove -all $procs $proc]
  133.             
  134.             foreach oldproc $procs {
  135.                 set aecoerce::coercions \
  136.                   [lremove -all ${aecoerce::coercions} \
  137.                     [list $from $to $oldproc] \
  138.                   ]
  139.             }
  140.         }
  141.     }
  142.     lappend aecoerce::coercions [list $from $to $proc]
  143.     set aecoerce::coercions [lunique ${aecoerce::coercions}]
  144. }
  145.  
  146. proc aecoerce::apply {value to {typed 0}} {
  147.     global aecoerce::coercions aecoerce::overrides aecoerce::noCoerce
  148.     
  149.     set from [lindex $value 0]
  150.     set value [lindex $value 1]
  151.     
  152.     if {$from == "list"} {
  153.         set msg "Cannot coerce a list"
  154.         error $msg "" [list AECoerce 18 $msg]
  155.     } 
  156.     
  157.     # no need to do anything for an identity coercion
  158.     if {$from != $to} {        
  159.         set coerce [list $from $to]
  160.         
  161.         foreach noCoerce ${aecoerce::noCoerce} {
  162.             if {[string match $noCoerce $coerce]} {
  163.                 # return what was sent
  164.                 return [list $from $value]
  165.             }     
  166.         }
  167.         
  168.         # coercion not blocked, so see if we know how to do it
  169.         if {[set i [lsearch -glob ${aecoerce::overrides} [list $from $to *]]] != -1} {
  170.             set value [[lindex [lindex ${aecoerce::overrides} $i] 2] $value]
  171.         } elseif {[set i [lsearch -glob ${aecoerce::coercions} [list $from $to *]]] != -1} {
  172.             set value [[lindex [lindex ${aecoerce::coercions} $i] 2] $value]
  173.         } else {
  174.             # -1700 is a coercion failure.
  175.             # That's not exactly what we want; coercion didn't
  176.             # fail, we just don't know how to do it.
  177.             set msg "Can't coerce '$from' to '$to'"
  178.             error $msg "" [list AECoerce 1700 $msg]
  179.         }
  180.     }
  181.     if {$typed} {
  182.         return [list $to $value]
  183.     } else {
  184.         return $value
  185.     } 
  186. }
  187.     
  188. # !!! NEEDS TO BE IMPLEMENTED !!!
  189. proc aecoerce::deregister {hook {procname ""} args} {
  190.     if {![llength $args]} {set args "*"}
  191.     namesp hook::${hook}
  192.     global hook::${hook}
  193.     if {$procname == ""} { 
  194.         # clear all hooks
  195.         unset hook::${hook} 
  196.     } else {        
  197.         foreach mode $args {
  198.             if {[info exists hook::${hook}($mode)] \
  199.             && ([set i [lsearch -exact [set hook::${hook}($mode)] $procname]] != -1)} {
  200.             set new [lreplace hook::${hook}($mode) $i $i]
  201.             if {$new != ""} {
  202.                 set hook::${hook}($mode) $new
  203.             } else {
  204.                 unset hook::${hook}($mode)
  205.             }
  206.             }
  207.         }
  208.     }
  209. }
  210.  
  211. # ◊◊◊◊ Default Coercions ◊◊◊◊ #
  212.  
  213. aecoerce::register "hexd" "bool" aecoerce::hexd:bool
  214. aecoerce::register "hexd" "TEXT" aecoerce::hexd:TEXT
  215. aecoerce::register "null" "TEXT" aecoerce::null:TEXT
  216. aecoerce::register "hexd" "alis" aecoerce::hexd:alis
  217. aecoerce::register "hexd" "fss " specToPathName
  218. aecoerce::register "TEXT" "alis" aecoerce::TEXT:alis
  219. aecoerce::register "shor" "long" aecoerce::identity
  220. aecoerce::register "long" "shor" aecoerce::identity
  221.  
  222.